#include <stdio.h>
#include <caml/alloc.h>
#include <caml/callback.h>
#include <caml/custom.h>
#include <caml/fail.h>
#include <caml/memory.h>
#include <caml/mlvalues.h>
#include <caml/signals.h>
#include <portmidi.h>

static value cons(value hd, value tl) {
	CAMLparam2(hd, tl);
	CAMLlocal1(ret);
	ret = caml_alloc_small(2, Tag_cons);
	Field(ret, 0) = hd;
	Field(ret, 1) = tl;
	CAMLreturn(ret);
}

static PmError pm_try(PmError e) {
	char *msg;
	if (e < 0) {
		if (e == pmHostError) {
			msg = alloca(PM_HOST_ERROR_MSG_LEN);
			Pm_GetHostErrorText(msg, PM_HOST_ERROR_MSG_LEN);
			caml_failwith(msg);
		}
		else caml_failwith((char *) Pm_GetErrorText(e));
	}
	else return e;
}

struct stream {
	PortMidiStream *stream;
	value callback;
};

#define Stream_val(v) ((struct stream *) Data_custom_val(v))

static void stream_finalize(value v) {
	struct stream *s = Stream_val(v);
	/* TODO: can we raise exceptions from the finalization callback? */
	if (s -> stream != NULL) {
		/* TODO: should we abort here?
		 * (i.e. can the callback still get called? */
		pm_try(Pm_Close(s -> stream));
		if (Is_block(s -> callback))
			caml_remove_global_root(&s -> callback);
	}
}

static struct custom_operations stream_ops = {
	"org.isa-geek.squirrel.portmidi.stream",
	stream_finalize,
	custom_compare_default,
	custom_hash_default,
	custom_serialize_default,
	custom_deserialize_default
};

static value alloc_stream(value callback) {
	CAMLparam1(callback);
	CAMLlocal1(v);
	struct stream *s;
	
	v = alloc_custom(&stream_ops, sizeof(struct stream), 1, 16);
	s = Stream_val(v);
	if (Is_block(callback)) caml_register_global_root(&s -> callback);
	s -> callback = callback;
	CAMLreturn(v);
}

CAMLprim value caml_Pm_Initialize(value unit) {
	CAMLparam1(unit);
	pm_try(Pm_Initialize());
	CAMLreturn(Val_unit);
}

CAMLprim value caml_Pm_Terminate(value unit) {
	CAMLparam1(unit);
	pm_try(Pm_Terminate());
	CAMLreturn(Val_unit);
}

CAMLprim value caml_Pm_HasHostError(value stream) {
	CAMLparam1(stream);
	CAMLreturn(Val_bool(Pm_HasHostError(Stream_val(stream) -> stream)));
}

CAMLprim value caml_Pm_CountDevices(value unit) {
	CAMLparam1(unit);
	CAMLreturn(Val_int(pm_try(Pm_CountDevices())));
}

CAMLprim value caml_Pm_GetDefaultInputDeviceID(value unit) {
	CAMLparam1(unit);
	CAMLlocal1(ret);
	PmDeviceID id;
	
	id = Pm_GetDefaultInputDeviceID();
	if (id != pmNoDevice) pm_try(id);
	CAMLreturn(Val_int(id));
	/*if (id == pmNoDevice) CAMLreturn(Val_int(0));
	else {
		pm_try(id);
		ret = caml_alloc_small(1, 0);
		Field(ret, 0) = Val_int(id);
		CAMLreturn(ret);
	}*/
}

CAMLprim value caml_Pm_GetDefaultOutputDeviceID(value unit) {
	CAMLparam1(unit);
	CAMLlocal1(ret);
	PmDeviceID id;
	
	id = Pm_GetDefaultOutputDeviceID();
	if (id != pmNoDevice) pm_try(id);
	CAMLreturn(Val_int(id));
	/*if (id == pmNoDevice) CAMLreturn(Val_int(0));
	else {
		pm_try(id);
		ret = caml_alloc_small(1, 0);
		Field(ret, 0) = Val_int(id);
		CAMLreturn(ret);
	}*/
}

CAMLprim value caml_Pm_GetDeviceInfo(value id) {
	CAMLparam1(id);
	CAMLlocal1(ret);
	const PmDeviceInfo *info;
	
	info = Pm_GetDeviceInfo(Int_val(id));
	if (info == NULL) caml_failwith("Device id out of range");
	else {
		ret = caml_alloc_tuple(4);
		Store_field(ret, 0, caml_copy_string(info -> interf));
		Store_field(ret, 1, caml_copy_string(info -> name));
		Store_field(ret, 2, Val_bool(info -> input));
		Store_field(ret, 3, Val_bool(info -> output));
		CAMLreturn(ret);
	}
}

static PmTimestamp caml_time_proc(struct stream *s) {
	/* TODO: should we check here for the block-ness of s -> callback?
	 * i.e. can we get called after the stream is closed? */
	return Int_val(caml_callback(Field(s -> callback, 0),
		Field(s -> callback, 1)));
}

CAMLprim value caml_Pm_OpenInput_Simple(value id, value bufsize) {
	CAMLparam2(id, bufsize);
	CAMLlocal1(ret);
	struct stream *s;
	
	ret = alloc_stream(Val_unit);
	s = Stream_val(ret);
	pm_try(Pm_OpenInput(&s -> stream, Int_val(id), NULL, Int_val(bufsize),
		NULL, NULL));
	CAMLreturn(ret);
}

CAMLprim value caml_Pm_OpenInput(value id, value bufsize, value fun, value arg) {
	CAMLparam2(id, bufsize);
	CAMLlocal1(ret);
	struct stream *s;
	
	ret = alloc_stream(cons(fun, arg));
	s = Stream_val(ret);
	pm_try(Pm_OpenInput(&s -> stream, Int_val(id), NULL, Int_val(bufsize),
		(PmTimeProcPtr) caml_time_proc, s));
	CAMLreturn(ret);
}

CAMLprim value caml_Pm_OpenOutput_Simple(value id, value bufsize, value latency) {
	CAMLparam3(id, bufsize, latency);
	CAMLlocal1(ret);
	struct stream *s;
	
	ret = alloc_stream(Val_unit);
	s = Stream_val(ret);
	pm_try(Pm_OpenOutput(&s -> stream, Int_val(id), NULL, Int_val(bufsize),
		NULL, NULL, Int_val(latency)));
	CAMLreturn(ret);
}

CAMLprim value caml_Pm_OpenOutput(value id, value bufsize, value fun, value arg, value latency) {
	CAMLparam5(id, bufsize, fun, arg, latency);
	CAMLlocal1(ret);
	struct stream *s;
	
	ret = alloc_stream(cons(fun, arg));
	s = Stream_val(ret);
	pm_try(Pm_OpenOutput(&s -> stream, Int_val(id), NULL, Int_val(bufsize),
		(PmTimeProcPtr) caml_time_proc, s, Int_val(latency)));
	CAMLreturn(ret);
}

CAMLprim value caml_Pm_SetFilter(value stream, value filters) {
	CAMLparam2(stream, filters);
	pm_try(Pm_SetFilter(Stream_val(stream) -> stream, Int_val(filters)));
	CAMLreturn(Val_unit);
}

CAMLprim value caml_Pm_Abort(value stream) {
	CAMLparam1(stream);
	struct stream *s = Stream_val(stream);
	
	pm_try(s -> stream == NULL ? pmBadPtr : pmNoError);
	pm_try(Pm_Abort(s -> stream));
	stream_finalize(stream);
	s -> stream = NULL;
	CAMLreturn(Val_unit);
}

CAMLprim value caml_Pm_Close(value stream) {
	CAMLparam1(stream);
	struct stream *s = Stream_val(stream);
	
	pm_try(s -> stream == NULL ? pmBadPtr : pmNoError);
	pm_try(Pm_Close(s -> stream));
	stream_finalize(stream);
	s -> stream = NULL;
	CAMLreturn(Val_unit);
}

CAMLprim value caml_Pm_Read(value stream, value length) {
	CAMLparam2(stream, length);
	CAMLlocal3(ret, event, message);
	PmEvent buffer[length];
	int n, b;
	
	n = pm_try(Pm_Read(Stream_val(stream) -> stream, buffer, Int_val(length)));
	ret = Val_emptylist;
	while (n-- > 0) {
		message = caml_alloc_string(sizeof(buffer[n].message));
		for (b = 0; b < sizeof(buffer[n].message); b++)
			String_val(message)[b] = (char) (buffer[n].message >> (8 * b));
		event = caml_alloc_small(2, 0);
		Field(event, 0) = message;
		Field(event, 1) = Val_int(buffer[n].timestamp);
		ret = cons(event, ret);
	}
	CAMLreturn(ret);
}

CAMLprim value caml_Pm_Poll(value stream) {
	CAMLparam1(stream);
	CAMLreturn(Val_bool(pm_try(Pm_Poll(Stream_val(stream) -> stream))));
}

CAMLprim value caml_Pm_Write(value stream, value data) {
	CAMLparam2(stream, data);
	CAMLlocal3(cur, event, message);
	PmEvent *buffer;
	int n, b, l;
	
	for (cur = data, n = 0; Is_block(cur); cur = Field(cur, 1), n++);
	buffer = caml_stat_alloc(n * sizeof(PmEvent));
	for (cur = data, n = 0; Is_block(cur); cur = Field(cur, 1), n++) {
		event = Field(cur, 0);
		message = Field(event, 0);
		l = caml_string_length(message);
		
		buffer[n].message = 0;
		for (b = 0; b < sizeof(buffer[n].message); b++) {
			if (b >= l) break;
			buffer[n].message |=
				((PmMessage) (unsigned char) String_val(message)[b]) << (8 * b);
		}
		buffer[n].timestamp = Int_val(Field(event, 1));
	}
	n = Pm_Write(Stream_val(stream) -> stream, buffer, n);
	caml_stat_free(buffer);
	
	pm_try(n);
	CAMLreturn(Val_unit);
}

CAMLprim value caml_Pm_WriteShort(value stream, value when, value message) {
	CAMLparam3(stream, when, message);
	PmMessage msg;
	int b, l;
	
	l = caml_string_length(message);
	msg = 0;
	for (b = 0; b < sizeof(msg); b++) {
		if (b >= l) break;
		msg |= ((PmMessage) (unsigned char) String_val(message)[b]) << (8 * b);
	}
	pm_try(Pm_WriteShort(Stream_val(stream) -> stream, Int_val(when), msg));
	CAMLreturn(Val_unit);
}

CAMLprim value caml_Pm_WriteSysEx(value stream, value when, value msg) {
	CAMLparam3(stream, when, msg);
	pm_try(Pm_WriteSysEx(Stream_val(stream) -> stream,
		Int_val(when), (unsigned char *) String_val(msg)));
	CAMLreturn(Val_unit);
}
